home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / list.d < prev    next >
Encoding:
Text File  |  1987-06-04  |  23.0 KB  |  1,198 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     list.d
  9.  
  10.     list manipulating routines
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. #undef endp
  16.  
  17. #define    endp(obje)    ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
  18.              FALSE : endp_temp == Cnil ? TRUE : \
  19.              (bool)FEwrong_type_argument(Slist, endp_temp))
  20.  
  21. object endp_temp;
  22.  
  23. object Ktest;
  24. object Ktest_not;
  25. object Kkey;
  26.  
  27. object Kinitial_element;
  28.  
  29. object test_function;
  30. object item_compared;
  31. bool (*tf)();
  32. #define    TEST(x)        (*tf)(x)
  33.  
  34. object key_function;
  35. object (*kf)();
  36.  
  37. #define    saveTEST  \
  38.     object old_test_function = test_function;  \
  39.     object old_item_compared = item_compared;  \
  40.     bool (*old_tf)() = tf;  \
  41.     object old_key_function = key_function;  \
  42.     object (*old_kf)() = kf;  \
  43.     bool eflag = FALSE
  44.  
  45. #define    protectTEST  \
  46.     frs_push(FRS_PROTECT, Cnil);  \
  47.     if (nlj_active) {  \
  48.         eflag = TRUE;  \
  49.         goto L;  \
  50.     }
  51.  
  52. #define    restoreTEST  \
  53. L:  \
  54.     frs_pop();  \
  55.     test_function = old_test_function;  \
  56.     item_compared = old_item_compared;  \
  57.     tf = old_tf;  \
  58.     key_function = old_key_function;  \
  59.     kf = old_kf;  \
  60.     if (eflag) {  \
  61.         nlj_active = FALSE;  \
  62.         unwind(nlj_fr, nlj_tag);  \
  63.     }
  64.  
  65. bool
  66. test_compare(x)
  67. object x;
  68. {
  69.     object b;
  70.  
  71.     vs_push((*kf)(x));
  72.     b = ifuncall2(test_function, item_compared, vs_head);
  73.     vs_pop;
  74.     return(b != Cnil);
  75. }
  76.  
  77. bool
  78. test_compare_not(x)
  79. object x;
  80. {
  81.     object b;
  82.  
  83.     vs_push((*kf)(x));
  84.     b = ifuncall2(test_function, item_compared, vs_head);
  85.     vs_pop;
  86.     return(b == Cnil);
  87. }
  88.  
  89. bool
  90. test_eql(x)
  91. object x;
  92. {
  93.     return(eql(item_compared, (*kf)(x)));
  94. }
  95.  
  96. object
  97. apply_key_function(x)
  98. object x;
  99. {
  100.     return(ifuncall1(key_function, x));
  101. }
  102.  
  103. object
  104. identity(x)
  105. object x;
  106. {
  107.     return(x);
  108. }
  109.  
  110. setupTEST(item, test, test_not, key)
  111. object item, test, test_not, key;
  112. {
  113.     item_compared = item;
  114.     if (test != Cnil) {
  115.         if (test_not != Cnil)
  116.             FEerror("Both :TEST and :TEST-NOT are specified.", 0);
  117.         test_function = test;
  118.         tf = test_compare;
  119.     } else if (test_not != Cnil) {
  120.         test_function = test_not;
  121.         tf = test_compare_not;
  122.     } else
  123.         tf = test_eql;
  124.     if (key != Cnil) {
  125.         key_function = key;
  126.         kf = apply_key_function;
  127.     } else
  128.         kf = identity;
  129. }
  130.  
  131. #define    PREDICATE(f, f_if, f_if_not, n)  \
  132. f_if()  \
  133. {  \
  134.     if (vs_top - vs_base < n)  \
  135.         too_few_arguments();  \
  136.     vs_push(Ktest);  \
  137.     vs_push(Sfuncall);  \
  138.     f();  \
  139. }  \
  140. \
  141. f_if_not()  \
  142. {  \
  143.     if (vs_top - vs_base < n)  \
  144.         too_few_arguments();  \
  145.     vs_push(Ktest_not);  \
  146.     vs_push(Sfuncall);  \
  147.     f();  \
  148. }
  149.  
  150. bool
  151. endp1(x)
  152. object x;
  153. {
  154.     if (type_of(x) == t_cons)
  155.         return(FALSE);
  156.     else if (x == Cnil)
  157.         return(TRUE);
  158.     vs_push(x);
  159.     FEwrong_type_argument(Slist, x);
  160. }
  161.  
  162. object
  163. car(x)
  164. object x;
  165. {
  166.     if (x == Cnil)
  167.         return(x);
  168.     if (type_of(x) == t_cons)
  169.         return(x->c.c_car);
  170.     FEwrong_type_argument(Slist, x);
  171. }
  172.  
  173. object
  174. cdr(x)
  175. object x;
  176. {
  177.     if (x == Cnil)
  178.         return(x);
  179.     if (type_of(x) == t_cons)
  180.         return(x->c.c_cdr);
  181.     FEwrong_type_argument(Slist, x);
  182. }
  183.  
  184. object
  185. kar(x)
  186. object x;
  187. {
  188.     if (type_of(x) == t_cons)
  189.         return(x->c.c_car);
  190.     FEwrong_type_argument(Scons, x);
  191. }
  192.  
  193. object
  194. kdr(x)
  195. object x;
  196. {
  197.     if (type_of(x) == t_cons)
  198.         return(x->c.c_cdr);
  199.     FEwrong_type_argument(Scons, x);
  200. }
  201.  
  202. stack_cons()
  203. {
  204.     object c;
  205.  
  206.     c = alloc_object(t_cons);
  207.     c->c.c_cdr = vs_pop;
  208.     c->c.c_car = vs_pop;
  209.     *vs_top++ = c;
  210. }
  211.  
  212. #ifdef AV
  213. #define argn(n)        *(&first_arg + n)
  214. #endif
  215. #ifdef MV
  216.  
  217. #endif
  218.  
  219. object list(n, first_arg)
  220. int n;
  221. object first_arg;
  222. {
  223.     object *p = vs_top;
  224.  
  225.     vs_push(Cnil);
  226.     while (--n >= 0)
  227.         *p = make_cons(argn(n), *p);
  228.     return(vs_pop);
  229. }
  230.  
  231. object listA(n, first_arg)
  232. int n;
  233. object first_arg;
  234. {
  235.     object *p = vs_top;
  236.  
  237.     vs_push(argn(--n));
  238.     while (--n >= 0)
  239.         *p = make_cons(argn(n), *p);
  240.     return(vs_pop);
  241. }
  242.  
  243. #undef argn
  244.  
  245. bool
  246. tree_equal(x, y)
  247. object x, y;
  248. {
  249.     cs_check(x);
  250.  
  251. BEGIN:
  252.     if (type_of(x) == t_cons)
  253.         if (type_of(y) == t_cons)
  254.             if (tree_equal(x->c.c_car, y->c.c_car)) {
  255.                 x = x->c.c_cdr;
  256.                 y = y->c.c_cdr;
  257.                 goto BEGIN;
  258.             } else
  259.                 return(FALSE);
  260.         else
  261.             return(FALSE);
  262.     else {
  263.         item_compared = x;
  264.         if (TEST(y))
  265.             return(TRUE);
  266.         else
  267.             return(FALSE);
  268.     }
  269. }
  270.  
  271. object
  272. append(x, y)
  273. object x, y;
  274. {
  275.     object z;
  276.  
  277.     if (endp(x))
  278.         return(y);
  279.     z = make_cons(Cnil, Cnil);
  280.     vs_push(z);
  281.     for (;;) {
  282.         z->c.c_car = x->c.c_car;
  283.         x = x->c.c_cdr;
  284.         if (endp(x))
  285.             break;
  286.         z->c.c_cdr = make_cons(Cnil, Cnil);
  287.         z = z->c.c_cdr;
  288.     }
  289.     z->c.c_cdr = y;
  290.     return(vs_pop);
  291. }
  292.  
  293. /*
  294.     Copy_list(x) copies list x.
  295. */
  296. object
  297. copy_list(x)
  298. object x;
  299. {
  300.     object y;
  301.  
  302.     if (type_of(x) != t_cons)
  303.         return(x);
  304.     y = make_cons(x->c.c_car, Cnil);
  305.     vs_push(y);
  306.     for (x = x->c.c_cdr; type_of(x) == t_cons; x = x->c.c_cdr) {
  307.         y->c.c_cdr = make_cons(x->c.c_car, Cnil);
  308.         y = y->c.c_cdr;
  309.     }
  310.     y->c.c_cdr = x;
  311.     return(vs_pop);
  312. }
  313.  
  314. /*
  315.     Copy_alist(x) copies alist x.
  316. */
  317. object
  318. copy_alist(x)
  319. object x;
  320. {
  321.     object y;
  322.  
  323.     if (endp(x))
  324.         return(Cnil);
  325.     y = make_cons(Cnil, Cnil);
  326.     vs_push(y);
  327.     for (;;) {
  328.         y->c.c_car = make_cons(car(x->c.c_car), cdr(x->c.c_car));
  329.         x = x->c.c_cdr;
  330.         if (endp(x))
  331.             break;
  332.         y->c.c_cdr = make_cons(Cnil, Cnil);
  333.         y = y->c.c_cdr;
  334.     }
  335.     return(vs_pop);
  336. }
  337.  
  338. /*
  339.     Copy_tree(x) copies tree x
  340.     and pushes the result onto vs.
  341. */
  342. copy_tree(x)
  343. object x;
  344. {
  345.     cs_check(x);
  346.  
  347.     if (type_of(x) == t_cons) {
  348.         copy_tree(x->c.c_car);
  349.         copy_tree(x->c.c_cdr);
  350.         stack_cons();
  351.     } else
  352.         vs_check_push(x);
  353. }
  354.  
  355. /*
  356.     Subst(new, tree) pushes
  357.     the result of substituting new in tree
  358.     onto vs.
  359. */
  360. subst(new, tree)
  361. object new, tree;
  362. {
  363.     cs_check(new);
  364.  
  365.     if (TEST(tree))
  366.         vs_check_push(new);
  367.     else if (type_of(tree) == t_cons) {
  368.         subst(new, tree->c.c_car);
  369.         subst(new, tree->c.c_cdr);
  370.         stack_cons();
  371.     } else
  372.         vs_check_push(tree);
  373. }
  374.  
  375. /*
  376.     Nsubst(new, treep) stores
  377.     the result of nsubstituting new in *treep
  378.     to *treep.
  379. */
  380. nsubst(new, treep)
  381. object new, *treep;
  382. {
  383.     cs_check(new);
  384.  
  385.     if (TEST(*treep))
  386.         *treep = new;
  387.     else if (type_of(*treep) == t_cons) {
  388.         nsubst(new, &(*treep)->c.c_car);
  389.         nsubst(new, &(*treep)->c.c_cdr);
  390.     }
  391. }
  392.  
  393. /*
  394.     Sublis(alist, tree) pushes
  395.     result of substituting tree by alist
  396.     onto vs.
  397. */
  398. sublis(alist, tree)
  399. object alist, tree;
  400. {
  401.     object x;
  402.  
  403.     cs_check(alist);
  404.  
  405.     for (x = alist;  !endp(x);  x = x->c.c_cdr) {
  406.         item_compared = car(x->c.c_car);
  407.         if (TEST(tree)) {
  408.             vs_check_push(cdr(x->c.c_car));
  409.             return;
  410.         }
  411.     }
  412.     if (type_of(tree) == t_cons) {
  413.         sublis(alist, tree->c.c_car);
  414.         sublis(alist, tree->c.c_cdr);
  415.         stack_cons();
  416.     } else
  417.         vs_check_push(tree);
  418. }
  419.  
  420. /*
  421.     Nsublis(alist, treep) stores
  422.     the result of substiting *treep by alist
  423.     to *treep.
  424. */
  425. nsublis(alist, treep)
  426. object alist, *treep;
  427. {
  428.     object x;
  429.  
  430.     cs_check(alist);
  431.  
  432.     for (x = alist;  !endp(x);  x = x->c.c_cdr) {
  433.         item_compared = car(x->c.c_car);
  434.         if (TEST(*treep)) {
  435.             *treep = x->c.c_car->c.c_cdr;
  436.             return;
  437.         }
  438.     }
  439.     if (type_of(*treep) == t_cons) {
  440.         nsublis(alist, &(*treep)->c.c_car);
  441.         nsublis(alist, &(*treep)->c.c_cdr);
  442.     }
  443. }
  444.  
  445. Lcar()
  446. {
  447.     check_arg(1);
  448.  
  449.     if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil)
  450.         vs_base[0] = vs_base[0]->c.c_car;
  451.     else
  452.         FEwrong_type_argument(Slist, vs_base[0]);
  453. }
  454.  
  455. Lcdr()
  456. {
  457.     check_arg(1);
  458.  
  459.     if (type_of(vs_base[0]) == t_cons || vs_base[0] == Cnil)
  460.         vs_base[0] = vs_base[0]->c.c_cdr;
  461.     else
  462.         FEwrong_type_argument(Slist, vs_base[0]);
  463. }
  464.     
  465. object caar(x) object x;    {  return(car(car(x)));  }
  466. object cadr(x) object x;    {  return(car(cdr(x)));  }
  467. object cdar(x) object x;    {  return(cdr(car(x)));  }
  468. object cddr(x) object x;    {  return(cdr(cdr(x)));  }
  469. object caaar(x) object x;   {  return(car(car(car(x))));  }
  470. object caadr(x) object x;   {  return(car(car(cdr(x))));  }
  471. object cadar(x) object x;   {  return(car(cdr(car(x))));  }
  472. object caddr(x) object x;   {  return(car(cdr(cdr(x))));  }
  473. object cdaar(x) object x;   {  return(cdr(car(car(x))));  }
  474. object cdadr(x) object x;   {  return(cdr(car(cdr(x))));  }
  475. object cddar(x) object x;   {  return(cdr(cdr(car(x))));  }
  476. object cdddr(x) object x;   {  return(cdr(cdr(cdr(x))));  }
  477. object caaaar(x) object x;  {  return(car(car(car(car(x)))));  }
  478. object caaadr(x) object x;  {  return(car(car(car(cdr(x)))));  }
  479. object caadar(x) object x;  {  return(car(car(cdr(car(x)))));  }
  480. object caaddr(x) object x;  {  return(car(car(cdr(cdr(x)))));  }
  481. object cadaar(x) object x;  {  return(car(cdr(car(car(x)))));  }
  482. object cadadr(x) object x;  {  return(car(cdr(car(cdr(x)))));  }
  483. object caddar(x) object x;  {  return(car(cdr(cdr(car(x)))));  }
  484. object cadddr(x) object x;  {  return(car(cdr(cdr(cdr(x)))));  }
  485. object cdaaar(x) object x;  {  return(cdr(car(car(car(x)))));  }
  486. object cdaadr(x) object x;  {  return(cdr(car(car(cdr(x)))));  }
  487. object cdadar(x) object x;  {  return(cdr(car(cdr(car(x)))));  }
  488. object cdaddr(x) object x;  {  return(cdr(car(cdr(cdr(x)))));  }
  489. object cddaar(x) object x;  {  return(cdr(cdr(car(car(x)))));  }
  490. object cddadr(x) object x;  {  return(cdr(cdr(car(cdr(x)))));  }
  491. object cdddar(x) object x;  {  return(cdr(cdr(cdr(car(x)))));  }
  492. object cddddr(x) object x;  {  return(cdr(cdr(cdr(cdr(x)))));  }
  493.  
  494. Lcaar(){  check_arg(1);  vs_base[0] = car(car(vs_base[0]));  }
  495. Lcadr(){  check_arg(1);  vs_base[0] = car(cdr(vs_base[0]));  }
  496. Lcdar(){  check_arg(1);  vs_base[0] = cdr(car(vs_base[0]));  }
  497. Lcddr(){  check_arg(1);  vs_base[0] = cdr(cdr(vs_base[0]));  }
  498. Lcaaar(){  check_arg(1);  vs_base[0] = car(car(car(vs_base[0])));  }
  499. Lcaadr(){  check_arg(1);  vs_base[0] = car(car(cdr(vs_base[0])));  }
  500. Lcadar(){  check_arg(1);  vs_base[0] = car(cdr(car(vs_base[0])));  }
  501. Lcaddr(){  check_arg(1);  vs_base[0] = car(cdr(cdr(vs_base[0])));  }
  502. Lcdaar(){  check_arg(1);  vs_base[0] = cdr(car(car(vs_base[0])));  }
  503. Lcdadr(){  check_arg(1);  vs_base[0] = cdr(car(cdr(vs_base[0])));  }
  504. Lcddar(){  check_arg(1);  vs_base[0] = cdr(cdr(car(vs_base[0])));  }
  505. Lcdddr(){  check_arg(1);  vs_base[0] = cdr(cdr(cdr(vs_base[0])));  }
  506. Lcaaaar(){check_arg(1); vs_base[0] = car(car(car(car(vs_base[0]))));}
  507. Lcaaadr(){check_arg(1); vs_base[0] = car(car(car(cdr(vs_base[0]))));}
  508. Lcaadar(){check_arg(1); vs_base[0] = car(car(cdr(car(vs_base[0]))));}
  509. Lcaaddr(){check_arg(1); vs_base[0] = car(car(cdr(cdr(vs_base[0]))));}
  510. Lcadaar(){check_arg(1); vs_base[0] = car(cdr(car(car(vs_base[0]))));}
  511. Lcadadr(){check_arg(1); vs_base[0] = car(cdr(car(cdr(vs_base[0]))));}
  512. Lcaddar(){check_arg(1); vs_base[0] = car(cdr(cdr(car(vs_base[0]))));}
  513. Lcadddr(){check_arg(1); vs_base[0] = car(cdr(cdr(cdr(vs_base[0]))));}
  514. Lcdaaar(){check_arg(1); vs_base[0] = cdr(car(car(car(vs_base[0]))));}
  515. Lcdaadr(){check_arg(1); vs_base[0] = cdr(car(car(cdr(vs_base[0]))));}
  516. Lcdadar(){check_arg(1); vs_base[0] = cdr(car(cdr(car(vs_base[0]))));}
  517. Lcdaddr(){check_arg(1); vs_base[0] = cdr(car(cdr(cdr(vs_base[0]))));}
  518. Lcddaar(){check_arg(1); vs_base[0] = cdr(cdr(car(car(vs_base[0]))));}
  519. Lcddadr(){check_arg(1); vs_base[0] = cdr(cdr(car(cdr(vs_base[0]))));}
  520. Lcdddar(){check_arg(1); vs_base[0] = cdr(cdr(cdr(car(vs_base[0]))));}
  521. Lcddddr(){check_arg(1); vs_base[0] = cdr(cdr(cdr(cdr(vs_base[0]))));}
  522.  
  523. static int nth_count;
  524.  
  525. Lenth()
  526. {
  527.     check_arg(1);
  528.  
  529.     vs_base[0] = nth(nth_count, vs_base[0]);
  530. }
  531.  
  532. Lsecond() { nth_count = 1; Lenth(); }
  533. Lthird() { nth_count = 2; Lenth(); }
  534. Lfourth() { nth_count = 3; Lenth(); }
  535. Lfifth() { nth_count = 4; Lenth(); }
  536. Lsixth() { nth_count = 5; Lenth(); }
  537. Lseventh() { nth_count = 6; Lenth(); }
  538. Leighth() { nth_count = 7; Lenth(); }
  539. Lninth() { nth_count = 8; Lenth(); }
  540. Ltenth() { nth_count = 9; Lenth(); }
  541.  
  542. Lcons()
  543. {
  544.     object x;
  545.  
  546.     check_arg(2);
  547.     x = alloc_object(t_cons);
  548.     x->c.c_car = vs_base[0];
  549.     x->c.c_cdr = vs_base[1];
  550.     vs_base[0] = x;
  551.     vs_pop;
  552. }
  553.  
  554. @(defun tree_equal (x y &key test test_not)
  555. @
  556.     setupTEST(Cnil, test, test_not, Cnil);
  557.     if (tree_equal(x, y))
  558.         @(return Ct)
  559.     else
  560.         @(return Cnil)
  561. @)
  562.  
  563. Lendp()
  564. {
  565.     check_arg(1);
  566.  
  567.     if (vs_base[0] == Cnil) {
  568.         vs_base[0] = Ct;
  569.         return;
  570.     }
  571.     if (type_of(vs_base[0]) == t_cons) {
  572.         vs_base[0] = Cnil;
  573.         return;
  574.     }
  575.     FEwrong_type_argument(Slist, vs_base[0]);
  576. }
  577.  
  578. Llist_length()
  579. {
  580.     int n;
  581.     object fast, slow;
  582.  
  583.     check_arg(1);
  584.     n = 0;
  585.     fast = slow = vs_base[0];
  586.     for (;;) {
  587.         if (endp(fast)) {
  588.             vs_base[0] = make_fixnum(n);
  589.             return;
  590.         }
  591.         if (endp(fast->c.c_cdr)) {
  592.             vs_base[0] = make_fixnum(n + 1);
  593.             return;
  594.         }
  595.         if (fast == slow && n > 0) {
  596.             vs_base[0] = Cnil;
  597.             return;
  598.         }
  599.         n += 2;
  600.         fast = fast->c.c_cdr->c.c_cdr;
  601.         slow = slow->c.c_cdr;
  602.     }
  603. }
  604.  
  605. Lnth()
  606. {
  607.     check_arg(2);
  608.     vs_base[0] = nth(fixint(vs_base[0]), vs_base[1]);
  609.     vs_pop;
  610. }
  611.  
  612. object
  613. nth(n, x)
  614. int n;
  615. object x;
  616. {
  617.     if (n < 0) {
  618.         vs_push(make_fixnum(n));
  619.         FEerror("Negative index: ~D.", 1, vs_head);
  620.     }
  621.     while (n-- > 0)
  622.         if (endp(x)) {
  623.             return(Cnil);
  624.         } else
  625.             x = x->c.c_cdr;
  626.     if (endp(x))
  627.         return(Cnil);
  628.     else
  629.         return(x->c.c_car);
  630. }
  631.  
  632. Lnthcdr()
  633. {
  634.     check_arg(2);
  635.     vs_base[0] = nthcdr(fixint(vs_base[0]), vs_base[1]);
  636.     vs_pop;
  637. }
  638.  
  639. object
  640. nthcdr(n, x)
  641. int n;
  642. object x;
  643. {
  644.     if (n < 0) {
  645.         vs_push(make_fixnum(n));
  646.         FEerror("Negative index: ~D.", 1, vs_head);
  647.     }
  648.     while (n-- > 0)
  649.         if (endp(x)) {
  650.             return(Cnil);
  651.         } else
  652.             x = x->c.c_cdr;
  653.     return(x);
  654. }
  655.  
  656. Llast()
  657. {
  658.     check_arg(1);
  659.     if (endp(vs_base[0]))
  660.         return;
  661.         while (type_of(vs_base[0]->c.c_cdr) == t_cons)
  662.         vs_base[0] = vs_base[0]->c.c_cdr;
  663. }
  664.  
  665. Llist()
  666. {
  667.     vs_push(Cnil);
  668.     while (vs_top > vs_base + 1)
  669.         stack_cons();
  670. }
  671.  
  672. LlistA()
  673. {
  674.     if (vs_top == vs_base)
  675.         too_few_arguments();
  676.     while (vs_top > vs_base + 1)
  677.         stack_cons();
  678. }
  679.  
  680. @(defun make_list (size &key initial_element &aux x)
  681.     int i;
  682. @
  683.     check_type_non_negative_integer(&size);
  684.     if (type_of(size) != t_fixnum)
  685.         FEerror("Cannot make a list of the size ~D.", 1, size);
  686.     i = fix(size);
  687.     while (i-- > 0)
  688.         x = make_cons(initial_element, x);
  689.     @(return x)
  690. @)
  691.  
  692. Lappend()
  693. {
  694.     object x;
  695.  
  696.     if (vs_top == vs_base) {
  697.         vs_push(Cnil);
  698.         return;
  699.     }
  700.     while (vs_top > vs_base + 1) {
  701.         x = append(vs_top[-2], vs_top[-1]);
  702.         vs_top[-2] = x;
  703.         vs_pop;
  704.     }
  705. }
  706.  
  707. Lcopy_list()
  708. {
  709.     check_arg(1);
  710.     vs_base[0] = copy_list(vs_base[0]);
  711. }
  712.  
  713. Lcopy_alist()
  714. {
  715.     check_arg(1);
  716.     vs_base[0] = copy_alist(vs_base[0]);
  717. }
  718.  
  719. Lcopy_tree()
  720. {
  721.     check_arg(1);
  722.     copy_tree(vs_base[0]);
  723.     vs_base[0] = vs_pop;
  724. }
  725.  
  726. Lrevappend()
  727. {
  728.     object x, y;
  729.  
  730.     check_arg(2);
  731.     y = vs_pop;
  732.     for (x = vs_base[0];  !endp(x);  x = x->c.c_cdr) {
  733.         vs_push(x->c.c_car);
  734.         vs_push(y);
  735.         stack_cons();
  736.         y = vs_pop;
  737.     }
  738.     vs_base[0] = y;
  739. }
  740.  
  741. object
  742. nconc(x, y)
  743. object x, y;
  744. {
  745.     object x1;
  746.  
  747.     if (endp(x))
  748.         return(y);
  749.     for (x1 = x;  !endp(x1->c.c_cdr);  x1 = x1->c.c_cdr)
  750.         ;
  751.     x1->c.c_cdr = y;
  752.     return(x);
  753. }
  754.  
  755. Lnconc()
  756. {
  757.     object x, l, m;
  758.         int i, narg;
  759.     
  760.     narg = vs_top - vs_base - 1;
  761.     if (narg < 0) { vs_push(Cnil); return; }
  762.     x = Cnil;
  763.     for (i = 0;  i < narg;  i++) {
  764.         l = vs_base[i];
  765.         if (endp(l))
  766.             continue;
  767.         if (x == Cnil)
  768.             x = m = l;
  769.         else {
  770.             m->c.c_cdr = l;
  771.             m = l;
  772.         }
  773.         for (;  !endp(m->c.c_cdr);  m = m->c.c_cdr)
  774.             ;
  775.     }
  776.     if (x == Cnil) vs_base[0] = vs_top[-1];
  777.     else {
  778.         m->c.c_cdr = vs_top[-1];
  779.         vs_base[0] = x;
  780.     }
  781.     vs_top = vs_base+1;
  782. }
  783.  
  784. Lreconc()
  785. {
  786.     object x, y, z;
  787.  
  788.     check_arg(2);
  789.     y = vs_pop;
  790.     for (x = vs_base[0];  !endp(x);) {
  791.         z = x;
  792.         x = x->c.c_cdr;
  793.         z->c.c_cdr = y;
  794.         y = z;
  795.     }
  796.     vs_base[0] = y;
  797. }
  798.  
  799. @(defun butlast (lis &optional (nn `make_fixnum(1)`))
  800.     int i;
  801. @
  802.     check_type_non_negative_integer(&nn);
  803.     if (type_of(nn) != t_fixnum)
  804.         @(return Cnil)
  805.     for (i = 0;  !endp(lis);  i++, lis = lis->c.c_cdr)
  806.         vs_check_push(lis->c.c_car);
  807.     if (i <= fix((nn))) {
  808.         vs_top -= i;
  809.         @(return Cnil)
  810.     }
  811.     vs_top -= fix((nn));
  812.     i -= fix((nn));
  813.     vs_push(Cnil);
  814.     while (i-- > 0)
  815.         stack_cons();
  816.     lis = vs_pop;
  817.     @(return lis)
  818. @)
  819.  
  820. @(defun nbutlast (lis &optional (nn `make_fixnum(1)`))
  821.     int i;
  822.     object x;
  823. @
  824.     check_type_non_negative_integer(&nn);
  825.     if (type_of(nn) != t_fixnum)
  826.         @(return Cnil)
  827.     for (i = 0, x = lis;  !endp(x);  i++, x = x->c.c_cdr)
  828.         ;
  829.     if (i <= fix((nn)))
  830.         @(return Cnil)
  831.     for (i -= fix((nn)), x = lis;  --i > 0;  x = x->c.c_cdr)
  832.         ;
  833.     x->c.c_cdr = Cnil;
  834.     @(return lis)
  835. @)
  836.  
  837. Lldiff()
  838. {
  839.     int i;
  840.     object x;
  841.  
  842.     check_arg(2);
  843.     for (i = 0, x = vs_base[0];  !endp(x);  i++, x = x->c.c_cdr)
  844.         if (x == vs_base[1])
  845.             break;
  846.         else
  847.             vs_check_push(x->c.c_car);
  848.     vs_push(Cnil);
  849.     while (i-- > 0)
  850.         stack_cons();
  851.     vs_base[0] = vs_pop;
  852.     vs_pop;
  853. }
  854.  
  855. Lrplaca()
  856. {
  857.     check_arg(2);
  858.     check_type_cons(&vs_base[0]);
  859.     take_care(vs_base[1]);
  860.     vs_base[0]->c.c_car = vs_base[1];
  861.     vs_pop;
  862. }
  863.  
  864. Lrplacd()
  865. {
  866.     check_arg(2);
  867.     check_type_cons(&vs_base[0]);
  868.     vs_base[0]->c.c_cdr = vs_base[1];
  869.     vs_pop;
  870. }
  871.  
  872. @(defun subst (new old tree &key test test_not key)
  873.     saveTEST;
  874. @
  875.     protectTEST;
  876.     setupTEST(old, test, test_not, key);
  877.     subst(new, tree);
  878.     tree = vs_pop;
  879.     restoreTEST;
  880.     @(return tree)
  881. @)
  882.  
  883. PREDICATE(Lsubst, Lsubst_if, Lsubst_if_not, 3)
  884.  
  885. @(defun nsubst (new old tree &key test test_not key)
  886.     saveTEST;
  887. @
  888.     protectTEST;
  889.     setupTEST(old, test, test_not, key);
  890.     nsubst(new, &tree);
  891.     restoreTEST;
  892.     @(return tree)
  893. @)
  894.  
  895. PREDICATE(Lnsubst, Lnsubst_if, Lnsubst_if_not, 3)
  896.  
  897. @(defun sublis (alist tree &key test test_not key)
  898.     saveTEST;
  899. @
  900.     protectTEST;
  901.     setupTEST(Cnil, test, test_not, key);
  902.     sublis(alist, tree);
  903.     tree = vs_pop;
  904.     restoreTEST;
  905.     @(return tree)
  906. @)
  907.  
  908. @(defun nsublis (alist tree &key test test_not key)
  909.     saveTEST;
  910. @
  911.     protectTEST;
  912.     setupTEST(Cnil, test, test_not, key);
  913.     nsublis(alist, &tree);
  914.     restoreTEST;
  915.     @(return tree)
  916. @)
  917.  
  918. @(defun member (item list &key test test_not key)
  919.     saveTEST;
  920. @
  921.     protectTEST;
  922.     setupTEST(item, test, test_not, key);
  923.     while (!endp(list)) {
  924.         if (TEST(list->c.c_car))
  925.             goto L;
  926.         list = list->c.c_cdr;
  927.     }
  928.     restoreTEST;
  929.     @(return list)
  930. @)
  931.  
  932. PREDICATE(Lmember, Lmember_if, Lmember_if_not, 2)
  933.  
  934. @(defun member1 (item list &key test test_not key)
  935.     saveTEST;
  936. @
  937.     protectTEST;
  938.     if (key != Cnil)
  939.         item = ifuncall1(key, item);
  940.     setupTEST(item, test, test_not, key);
  941.     while (!endp(list)) {
  942.         if (TEST(list->c.c_car))
  943.             goto L;
  944.         list = list->c.c_cdr;
  945.     }
  946.     restoreTEST;
  947.     @(return list)
  948. @)
  949.  
  950. Ltailp()
  951. {
  952.     object x;
  953.  
  954.     check_arg(2);
  955.     for (x = vs_base[1];  !endp(x);  x = x->c.c_cdr)
  956.         if (x == vs_base[0]) {
  957.             vs_base[0] = Ct;
  958.             vs_pop;
  959.             return;
  960.         }
  961.     vs_base[0] = Cnil;
  962.     vs_pop;
  963.     return;
  964. }
  965.  
  966. Ladjoin()
  967. {
  968.     object *base = vs_base, *top = vs_top;
  969.  
  970.     if (vs_top - vs_base < 2)
  971.         too_few_arguments();
  972.     while (vs_base < top)
  973.         vs_push(*vs_base++);
  974.     Lmember1();
  975.     if (vs_base[0] == Cnil)
  976.         base[1] = make_cons(base[0], base[1]);
  977.     vs_base = base+1;
  978.     vs_top = base+2;
  979. }
  980.  
  981. Lacons()
  982. {
  983.     check_arg(3);
  984.  
  985.     vs_base[0] = make_cons(vs_base[0], vs_base[1]);
  986.     vs_base[0] = make_cons(vs_base[0], vs_base[2]);
  987.     vs_top -= 2;
  988. }
  989.  
  990. @(defun pairlis (keys data &optional a_list)
  991.     object *vp, k, d;
  992. @
  993.     vp = vs_top + 1;
  994.     k = keys;
  995.     d = data;
  996.     while (!endp(k)) {
  997.         if (endp(d))
  998.          FEerror(
  999.           "The keys ~S and the data ~S are not of the same length",
  1000.           2, keys, data);
  1001.         vs_check_push(make_cons(k->c.c_car, d->c.c_car));
  1002.         k = k->c.c_cdr;
  1003.         d = d->c.c_cdr;
  1004.     }
  1005.     if (!endp(d))
  1006.         FEerror("The keys ~S and the data ~S are not of the same length",
  1007.             2, keys, data);
  1008.     vs_push(a_list);
  1009.     while (vs_top > vp)
  1010.         stack_cons();
  1011.     @(return `vp[-1]`)
  1012. @)
  1013.  
  1014. static object (*car_or_cdr)();
  1015.  
  1016. @(defun assoc_or_rassoc (item a_list &key test test_not)
  1017.     saveTEST;
  1018. @
  1019.     protectTEST;
  1020.     setupTEST(item, test, test_not, Cnil);
  1021.     while (!endp(a_list)) {
  1022.         if (TEST((*car_or_cdr)(a_list->c.c_car))) {
  1023.             a_list = a_list->c.c_car;
  1024.             goto L;
  1025.         }
  1026.         a_list = a_list->c.c_cdr;
  1027.     }
  1028.     restoreTEST;
  1029.     @(return a_list)
  1030. @)
  1031.  
  1032. Lassoc() { car_or_cdr = car; Lassoc_or_rassoc(); }
  1033. Lrassoc() { car_or_cdr = cdr; Lassoc_or_rassoc(); }
  1034.  
  1035. static bool true_or_false;
  1036.  
  1037. @(defun assoc_or_rassoc_predicate (predicate a_list)
  1038. @
  1039.     while (!endp(a_list)) {
  1040.         if ((ifuncall1(predicate,
  1041.                    (*car_or_cdr)(a_list->c.c_car)) != Cnil)
  1042.             == true_or_false) {
  1043.             @(return `a_list->c.c_car`)
  1044.         }
  1045.         a_list = a_list->c.c_cdr;
  1046.     }
  1047.     @(return a_list)
  1048. @)
  1049.  
  1050. Lassoc_if() { car_or_cdr = car; true_or_false = TRUE; Lassoc_or_rassoc_predicate(); }
  1051. Lassoc_if_not() { car_or_cdr = car; true_or_false = FALSE; Lassoc_or_rassoc_predicate(); }
  1052. Lrassoc_if() { car_or_cdr = cdr; true_or_false = TRUE; Lassoc_or_rassoc_predicate(); }
  1053. Lrassoc_if_not() { car_or_cdr = cdr; true_or_false = FALSE; Lassoc_or_rassoc_predicate(); }
  1054.  
  1055. bool
  1056. member_eq(x, l)
  1057. object x, l;
  1058. {
  1059.     for (;  type_of(l) == t_cons;  l = l->c.c_cdr)
  1060.         if (x == l->c.c_car)
  1061.             return(TRUE);
  1062.     return(FALSE);
  1063. }
  1064.  
  1065. siLmemq()
  1066. {
  1067.     object x, l;
  1068.  
  1069.     check_arg(2);
  1070.  
  1071.     x = vs_base[0];
  1072.     l = vs_base[1];
  1073.  
  1074.     for (;  type_of(l) == t_cons;  l = l->c.c_cdr)
  1075.         if (x == l->c.c_car) {
  1076.             vs_base[0] = l;
  1077.             vs_pop;
  1078.             return;
  1079.         }
  1080.     
  1081.     vs_base[0] = Cnil;
  1082.     vs_pop;
  1083. }
  1084.  
  1085. delete_eq(x, lp)
  1086. object x, *lp;
  1087. {
  1088.     for (;  type_of(*lp) == t_cons;  lp = &(*lp)->c.c_cdr)
  1089.         if ((*lp)->c.c_car == x) {
  1090.             *lp = (*lp)->c.c_cdr;
  1091.             return;
  1092.         }
  1093. }
  1094.  
  1095. init_list_function()
  1096. {
  1097.     Ktest = make_keyword("TEST");
  1098.     Ktest_not = make_keyword("TEST-NOT");
  1099.     Kkey = make_keyword("KEY");
  1100.  
  1101.     Kinitial_element = make_keyword("INITIAL-ELEMENT");
  1102.  
  1103.     make_function("CAR", Lcar);
  1104.     make_function("CDR", Lcdr);
  1105.  
  1106.     make_function("CAAR", Lcaar);
  1107.     make_function("CADR", Lcadr);
  1108.     make_function("CDAR", Lcdar);
  1109.     make_function("CDDR", Lcddr);
  1110.     make_function("CAAAR", Lcaaar);
  1111.     make_function("CAADR", Lcaadr);
  1112.     make_function("CADAR", Lcadar);
  1113.     make_function("CADDR", Lcaddr);
  1114.     make_function("CDAAR", Lcdaar);
  1115.     make_function("CDADR", Lcdadr);
  1116.     make_function("CDDAR", Lcddar);
  1117.     make_function("CDDDR", Lcdddr);
  1118.     make_function("CAAAAR", Lcaaaar);
  1119.     make_function("CAAADR", Lcaaadr);
  1120.     make_function("CAADAR", Lcaadar);
  1121.     make_function("CAADDR", Lcaaddr);
  1122.     make_function("CADAAR", Lcadaar);
  1123.     make_function("CADADR", Lcadadr);
  1124.     make_function("CADDAR", Lcaddar);
  1125.     make_function("CADDDR", Lcadddr);
  1126.     make_function("CDAAAR", Lcdaaar);
  1127.     make_function("CDAADR", Lcdaadr);
  1128.     make_function("CDADAR", Lcdadar);
  1129.     make_function("CDADDR", Lcdaddr);
  1130.     make_function("CDDAAR", Lcddaar);
  1131.     make_function("CDDADR", Lcddadr);
  1132.     make_function("CDDDAR", Lcdddar);
  1133.     make_function("CDDDDR", Lcddddr);
  1134.  
  1135.     make_function("CONS", Lcons);
  1136.     make_function("TREE-EQUAL", Ltree_equal);
  1137.     make_function("ENDP", Lendp);
  1138.     make_function("LIST-LENGTH", Llist_length);
  1139.     make_function("NTH", Lnth);
  1140.  
  1141.     make_function("FIRST", Lcar);
  1142.     make_function("SECOND", Lsecond);
  1143.     make_function("THIRD", Lthird);
  1144.     make_function("FOURTH", Lfourth);
  1145.     make_function("FIFTH", Lfifth);
  1146.     make_function("SIXTH", Lsixth);
  1147.     make_function("SEVENTH", Lseventh);
  1148.     make_function("EIGHTH", Leighth);
  1149.     make_function("NINTH", Lninth);
  1150.     make_function("TENTH", Ltenth);
  1151.  
  1152.     make_function("REST", Lcdr);
  1153.     make_function("NTHCDR", Lnthcdr);
  1154.     make_function("LAST", Llast);
  1155.     make_function("LIST", Llist);
  1156.     make_function("LIST*", LlistA);
  1157.     make_function("MAKE-LIST", Lmake_list);
  1158.     make_function("APPEND", Lappend);
  1159.     make_function("COPY-LIST", Lcopy_list);
  1160.     make_function("COPY-ALIST", Lcopy_alist);
  1161.     make_function("COPY-TREE", Lcopy_tree);
  1162.     make_function("REVAPPEND", Lrevappend);
  1163.     make_function("NCONC", Lnconc);
  1164.     make_function("NRECONC", Lreconc);
  1165.  
  1166.     make_function("BUTLAST", Lbutlast);
  1167.     make_function("NBUTLAST", Lnbutlast);
  1168.     make_function("LDIFF", Lldiff);
  1169.     make_function("RPLACA", Lrplaca);
  1170.     make_function("RPLACD", Lrplacd);
  1171.     make_function("SUBST", Lsubst);
  1172.     make_function("SUBST-IF", Lsubst_if);
  1173.     make_function("SUBST-IF-NOT", Lsubst_if_not);
  1174.     make_function("NSUBST", Lnsubst);
  1175.     make_function("NSUBST-IF", Lnsubst_if);
  1176.     make_function("NSUBST-IF-NOT", Lnsubst_if_not);
  1177.     make_function("SUBLIS", Lsublis);
  1178.     make_function("NSUBLIS", Lnsublis);
  1179.     make_function("MEMBER", Lmember);
  1180.     make_function("MEMBER-IF", Lmember_if);
  1181.     make_function("MEMBER-IF-NOT", Lmember_if_not);
  1182.     make_si_function("MEMBER1", Lmember1);
  1183.     make_function("TAILP", Ltailp);
  1184.     make_function("ADJOIN", Ladjoin);
  1185.  
  1186.     make_function("ACONS", Lacons);
  1187.     make_function("PAIRLIS", Lpairlis);
  1188.     make_function("ASSOC", Lassoc);
  1189.     make_function("ASSOC-IF", Lassoc_if);
  1190.     make_function("ASSOC-IF-NOT", Lassoc_if_not);
  1191.     make_function("RASSOC", Lrassoc);
  1192.     make_function("RASSOC-IF", Lrassoc_if);
  1193.     make_function("RASSOC-IF-NOT", Lrassoc_if_not);
  1194.  
  1195.     make_si_function("MEMQ", siLmemq);
  1196.  
  1197. }
  1198.